;;written by John Jeziorski, Kendall Smith, and Jordan Arentsen.

(define scanner-spec-hw7
  '((white-sp
     (whitespace) skip)
    (comment
     ("%" (arbno (not #\newline))) skip)
    (identifier
     (letter (arbno (or letter digit "?"))) symbol)
    (number
     (digit (arbno digit)) number)
    (true
     ("#t") symbol)
    (false
     ("#f") symbol)))

;                                                                 
;                                                                 
;                                                                 
;                                                                 
;    *+###+ *@$#@#+     +$:   +$+   +$++$+   +$+   +$:   *@$#@#+  
;   +$+  +$  +$  +$:    +$+    $#   +$  $#   +$    +$+    +$  +$: 
;   @+    $  +$   $+    #+#    @$   @$  @$   @$    #+#    +$   $+ 
;  +$:       +$   $+   +++$    #++ ++$  #++ ++$   +++$    +$   $+ 
;  +$        +$  +#    ++ $+   #++ ++$  #++ ++$   ++ $+   +$  +#  
;  +$        +$+##-    #  #+   #:# #:$  #:# #:$   #  #+   +$+##-  
;  +$   +##  +$:+$    :+  +$   # #++-$  # #++-$  :+  +$   +$:+$   
;  *$:   +$  +$  #+   +@###$*  # +#+-$  # +#+-$  +@###$*  +$  #+  
;   #+   +$  +$  +$-  #    #+  # +$ -$  # +$ -$  #    #+  +$  +$- 
;   +$+  +$  +$   #+  #    +#  #  + -$  #  + -$  #    +#  +$   #+ 
;    :+@$#+ *@$#  +$++$+  +@$++$+   +$++$+   +$++$+  +@$+*@$#  +$+
;                                                                 
;                                                                 
;                                                                 
;                                                         ########

(define grammar-spec-hw7
  '((exp (number) lit-exp)
    (exp (identifier) var-exp)
    (exp ("(" subexp ")") sub-exp)
 
    (subexp ("lambda" "(" (arbno identifier) ")" exp) lambda-exp)
    (subexp ("if" boolexp exp exp) if-exp)
    (subexp ("cond" "(" (arbno boolexp exp ")" "(") "else" exp ")") cond-exp)
    ;(subexp ("add" exp exp) add-prim)
    ;(subexp ("sub" exp exp) subtract-prim)
    ;(subexp ("mul" exp exp) mult-prim)
    ;(subexp ("div" exp exp) div-prim)
    ;(subexp ("mod" exp exp) mod-prim)
    (subexp ("let" "(" (arbno "(" identifier exp ")") ")" exp) let-exp)
    (subexp ("letrec" "(" (arbno "(" identifier "(" "lambda" "(" 
                                 (arbno identifier) ")" exp ")" ")" ) ")" exp) letrec-exp)
    (subexp (exp (arbno exp)) app-exp)
    
    (boolexp (true) true-exp)
    (boolexp (false) false-exp)
    (boolexp ("(" boolsubexp ")") bool-sub-exp)
    
    (boolsubexp ("and" boolexp boolexp) and-exp)
    (boolsubexp ("or" boolexp boolexp) or-exp)
    (boolsubexp ("xor" boolexp boolexp) xor-exp)
    (boolsubexp ("equal" exp exp) equal-exp)
    (boolsubexp ("greater" exp exp) greater-exp)
    (boolsubexp ("lesser" exp exp) lesser-exp)))

(define-datatype s-exp s-exp?
  (empty-list)
  (atom (a atom?))
  (cons-cell (ca s-exp?)
             (cd s-exp?)))

(define parse
  (sllgen:make-string-parser scanner-spec-hw7 grammar-spec-hw7))
(sllgen:make-define-datatypes scanner-spec-hw7 grammar-spec-hw7)

;                                                                 
;                                                                 
;                                                                 
;                                                                 
;  :#$#  #$++$+   #$++#$####:    +$:   *#$###+    +###+: *#$##### 
;   +$    #  ##    #   $+  ##    +$+    +$  +$:  ++   #+   $+   # 
;   +$    #  #$+   #   $+  +$    #+#    +$   $+  $+   ++   $+   + 
;   +$    #  #+$:  #   $+  +#   +++$    +$   $+  #+        $+     
;   +$    #  # ##  #   $+  #+   ++ $+   +$  +#   *##+      $+ ++  
;   +$    #  # +$+ #   $+++#    #  #+   +$+##-     +##+    $###+  
;   +$    #  #  ## #   $+++    :+  +$   +$:+$        +$+   $+ ++  
;   +$    #  #  :$+#   $+      +####$*  +$  #+   -    +#   $+     
;   :$:  :+  #   +$#   $+      #    #+  +$  +$-  +    +#   $+   + 
;    #+  ++  #    ##   $+      #    +#  +$   #+  #*  :#+   $+   # 
;    -+##+  +$#   +# +#$##+   +$+  +#$+*#$#  +$+ ++###+  *#$$$$$# 
;                                                                 
;                                                                 
;                                                                 
;                                                         $$$$$$$$

; Returns a parsed expression to its original syntax
(define unparse
  (lambda (x)
    (cond
      ((exp? x)
       (cases exp x
         (lit-exp (num) num)
         (var-exp (id) id)
         (sub-exp (se) (unparse se))))
      ((subexp? x)
       (cases subexp x
         (lambda-exp (ids body)
                     (list 'lambda ids (unparse body)))
         (if-exp (test-exp true-exp false-exp)
                 (list 'if (list (unparse test-exp)) (unparse true-exp) (unparse false-exp)))
         (cond-exp (lst cond_else else_exp) 
                   (cons 'cond (append-item (unparse-cond-helper lst cond_else) (list 'else (unparse else_exp)))))
;         (add-prim (exp1 exp2) (list 'add (unparse exp1) (unparse exp2)))
;         (subtract-prim (exp1 exp2) (list 'sub (unparse exp1) (unparse exp2)))
;         (mult-prim (exp1 exp2) (list 'mul (unparse exp1) (unparse exp2)))
;         (div-prim (exp1 exp2) (list 'div (unparse exp1) (unparse exp2)))
;         (mod-prim (exp1 exp2) (list 'mod (unparse exp1) (unparse exp2)))
         (let-exp (ids vals body) (list 'let (unparse-let-helper ids (map unparse vals)) (unparse body)))
         (letrec-exp (proc-names idss bodies letrec-body) 
                     (list 'letrec (unparse-letrec-helper proc-names idss bodies) (unparse letrec-body)))
         (app-exp (rator rands)
                  (cons (unparse rator) (map unparse rands)))))
      ((boolexp? x)
       (cases boolexp x
         (true-exp (true) #t)
         (false-exp (false) #f)
         (bool-sub-exp (exp) (unparse exp))))
      ((boolsubexp? x)
       (cases boolsubexp x
         (and-exp (exp1 exp2) (list 'and (unparse exp1) (unparse exp2)))
         (or-exp (exp1 exp2) (list 'or (unparse exp1) (unparse exp2)))
         (xor-exp (exp1 exp2) (list 'xor (unparse exp1) (unparse exp2)))
         (equal-exp (exp1 exp2) (list 'equal (unparse exp1) (unparse exp2)))
         (greater-exp (exp1 exp2) (list 'greater (unparse exp1) (unparse exp2)))
         (lesser-exp (exp1 exp2) (list 'lesser (unparse exp1) (unparse exp2)))))
      (else (eopl:error 'unparse "Unexpected type. Given ~S." x)))))

;this is a helper function to match up the ids and values for unparse
(define unparse-let-helper
  (lambda (ids vals)
    (cond
      ((or (null? ids) (null? vals)) '())
       (else (cons (list (car ids) (car vals)) (unparse-let-helper (cdr ids) (cdr vals)))))))

;this is a helper function to match up the names, parameters, and unparsed bodies for unparse
(define unparse-letrec-helper
  (lambda (procnames idss bodies)
    (cond
      ((or (or (null? procnames) (null? idss)) (null? bodies)) '())
      (else (cons (list (car procnames) (list 'lambda (car idss) (unparse (car bodies)))) 
                  (unparse-letrec-helper (cdr procnames) (cdr idss) (cdr bodies)))))))

;this is a helper function for cond statement unparsing.
(define unparse-cond-helper
  (lambda (l1 l2)
    (cond
      ((not (eqv? (length l1) (length l2))) 
       (eopl:error 'unparse-cond-helper 
                   "The syntax for cond is malformed. There should be an expression per each boolean expression."))
      ((and (null? l1) (null? l2)) '())
      ((and (null? (cdr l1)) (null? (cdr l2))) (list (unparse (car l1)) (unparse (car l2))))
      (else (list (list (unparse (car l1)) (unparse (car l2))) (unparse-cond-helper (cdr l1) (cdr l2)))))))

;this tacks an item on the end of a list.
(define append-item
  (lambda (lst a)
    (if (null? lst) (list a) (cons(car lst)(append-item (cdr lst) a)))))

;                                                                          
;                                                                          
;                                                                          
;                                                                          
;  *#$@#### +$#*  #$+   +$:   -#@$#+   :@$#  #$+   +$:   ###@$##$ *#$@#### 
;    $+   #  $+    #    +$+     +$      +$    #    +$+   #  +$  #   $+   # 
;    $+   +  #+   *+    #+#     +$      +$    #    #+#   #  +$  #   $+   + 
;    $+      +@   ++   +++$     +$      +$    #   +++$      +$      $+     
;    $+ ++   :$:  #    ++ $+    +$      +$    #   ++ $+     +$      $+ ++  
;    $@#@+    #+ :+    #  #+    +$      +$    #   #  #+     +$      $@#@+  
;    $+ ++    +# ++   :+  +$    +$      +$    #  :+  +$     +$      $+ ++  
;    $+       +$-#    +@###$*   +$   +  +$    #  +@###$*    +$      $+     
;    $+   +    $+#    #    #+   +$   #  :$:  :+  #    #+    +$      $+   + 
;    $+   #    +$+    #    +#   +$   #   #+  ++  #    +#    +$      $+   # 
;  *#$$$$$#    +$:   +$+  +@$+-#@$$$$$   -+@#+  +$+  +@$+ +#@$#+  *#$$$$$# 
;                                                                          
;                                                                          
;                                                                          
;                                                                  #+$$$# $

; Evaluates a parsed expression
(define run-eval
  (lambda (ast)
    (evaluate ast (default-env (empty-env)))))

(define evaluate
  (lambda (ast env)
    (cond
      ((null? ast) (eopl:error 'evaluate "Cannot evaluate null value."))
      ((exp? ast)
       (cases exp ast
         (lit-exp (num) num)
         (var-exp (id) (apply-env id env))
         (sub-exp (exp) (evaluate exp env))))
      ((subexp? ast)
       (cases subexp ast
         (if-exp (test-exp true-exp false-exp)
                 (if (evaluate test-exp env)
                     (evaluate true-exp env) (evaluate false-exp env)))
         (cond-exp (bools exps cond-else-exp) 
                   (eval-cond bools exps cond-else-exp env))
         (lambda-exp (ids body) (closure ids body env))
         (let-exp (ids vals body) 
                  (let ((args (eval-vals vals env)))
                    (evaluate body (extend-env ids args env))))
;         (add-prim (exp1 exp2) (+ (evaluate exp1 env) (evaluate exp2 env)))
;         (subtract-prim (exp1 exp2) (- (evaluate exp1 env) (evaluate exp2 env)))
;         (mult-prim (exp1 exp2) (* (evaluate exp1 env) (evaluate exp2 env)))
;         (div-prim (exp1 exp2) (quotient (evaluate exp1 env) (evaluate exp2 env)))
;         (mod-prim (exp1 exp2) (modulo (evaluate exp1 env) (evaluate exp2 env)))
         (app-exp (rator rands)
                  (let ((proc (evaluate rator env))
                        (args (eval-vals rands env)))
                    (if (procval? proc)
                        (apply-proc proc args)
                        (eopl:error 'eval-expression
                                    "Attempt to apply non-procedure ~s" proc))))
                        
         (letrec-exp (proc-names idss bodies letrec-body)
                     (evaluate letrec-body (extend-env-recursive proc-names idss bodies env)))))
      ((boolexp? ast)
       (cases boolexp ast
         (true-exp (true) #t)
         (false-exp (false) #f)
         (bool-sub-exp (exp) (evaluate exp env))))
      ((boolsubexp? ast)
       (cases boolsubexp ast
         (and-exp (exp1 exp2) (and (evaluate exp1 env) (evaluate exp2 env)))
         (or-exp (exp1 exp2) (or (evaluate exp1 env) (evaluate exp2 env)))
         (xor-exp (exp1 exp2) (and (not (and (evaluate exp1 env) (evaluate exp2 env)))
                                   (or (evaluate exp1 env) (evaluate exp2 env))))
         (equal-exp (exp1 exp2) (eqv? (evaluate exp1 env) (evaluate exp2 env)))
         (greater-exp (exp1 exp2) (> (evaluate exp1 env) (evaluate exp2 env)))
         (lesser-exp (exp1 exp2) (< (evaluate exp1 env) (evaluate exp2 env)))))
      (else (eopl:error 'evaluate "Unexpected type. Given ~S." x)))))


; This helper function helps evaluate a cond statement, 
; because it can have a variable amount of boolean expressions.
(define eval-cond
  (lambda (l1 l2 else-exp env)
    (cond
      ((not (eqv? (length l1) (length l2)))
       (eopl:error 'eval-cond-exp "Syntax Error: Should be one expression for each boolean expression."))
      ((eqv? (evaluate (car l1) env) #t) (evaluate (car l2) env))
      ((and (null? (cdr l1)) (null? (cdr l2))) (evaluate else-exp env))
      (else (eval-cond (cdr l1) (cdr l2) else-exp)))))

(define eval-vals
  (lambda (vals env)
    (map (lambda (x) (eval-val x env)) vals)))

(define eval-val
  (lambda (val env)
    (evaluate val env)))
      
;                                                                                          
;                                                                                          
;                                                                                          
;                                                                                          
;   ###### ###  ######  ###  #####  #####     ###  ###  ### ### ### ###### ###  ### #######
;    #   #  ##   #  #    #     #     #   #   #   #  ##   #   ## ##   #   #  ##   #  #  #  #
;    # #    # #  #  #    #     #     #   #  #     # # #  #   ## ##   # #    # #  #     #   
;    ###    # #  #   #  #      #     #   #  #     # # #  #   # # #   ###    # #  #     #   
;    # #    #  # #   #  #      #     ####   #     # #  # #   # # #   # #    #  # #     #   
;    #      #  # #   #  #      #     #  #   #     # #  # #   #   #   #      #  # #     #   
;    #   #  #   ##    ##       #     #   #   #   #  #   ##   #   #   #   #  #   ##     #   
;   ###### ###  ##    ##     #####  ###   #   ###  ###  ##  ### ### ###### ###  ##    ###  
;                                                                                          
;                                                                                          
;                                                                                          
;                                                                                          

(define-datatype environment environment?
  (empty-env)
  (extend-env (ids (list-of symbol?)) (vals list?) (tail environment?))
  (extend-env-recursive (proc-names (list-of symbol?)) 
                        (idss (list-of (list-of symbol?))) 
                        (bodies list?)
                        (tail environment?)))

(define apply-env
  (lambda (a env)
    (cases environment env
      (empty-env () (eopl:error 'apply-env "Reference to undefined identifier: ~S." a))
      (extend-env (ids vals tail) 
                  (if (member? a ids) (apply-env-helper a ids vals)
                      (apply-env a tail)))
      (extend-env-recursive (proc-names idss bodies tail)
                            (if (member? a proc-names) 
                                (closure (apply-env-helper a proc-names idss)
                                         (apply-env-helper a proc-names bodies) env)
                                (apply-env (a env)))))))

(define apply-env-helper
  (lambda (a ids vals)
    (cond
      ((or (null? ids) (null? vals)) (eopl:error 'apply-env-helper "Null encountered."))
      ((eqv? a (car ids)) (car vals))
      (else (apply-env-helper a (cdr ids) (cdr vals))))))

(define env-test
  (lambda ()
    (apply-env 'x (extend-env '(a b) '(5 6) (extend-env '(z y x) '(1 2 3) (empty-env))))))

(define member?
  (lambda (a lst)
    (cond
      ((null? lst) #f)
      ((eqv? a (car lst)) #t)
      (else (member? a (cdr lst))))))

(define-datatype procval procval?
  (closure (ids (list-of symbol?)) (body exp?) (env environment?))
  (primitive (procname symbol?) (argnum number?) (body procedure?)))


(define primitive-list
  (list 
   (primitive 'add 2 (lambda (x y) (+ x y)))
   (primitive 'sub 2 (lambda (x y) (- x y)))
   (primitive 'mul 2 (lambda (x y) (* x y)))
   (primitive 'div 2 (lambda (x y) (quotient x y)))
   (primitive 'mod 2 (lambda (x y) (modulo x y)))
   ))

(define default-env
  (lambda (env)
      (default-env-helper primitive-list env)))

(define default-env-helper
  (lambda (primitives env)
    (cond
      ((not (null? primitives))
       (cases procval (car primitives) 
         (closure (ids body env) (eopl:error 'default-env-helper "There should not be a closure here"))
         (primitive (procname argnum body)
                    (if (> (length primitives) 1)
                        (default-env-helper (cdr primitives) (extend-env (list procname) (list (car primitives)) env))
                        (extend-env (list procname) (list (car primitives)) env))))))))


(define apply-proc
  (lambda (proc args)
    (cases procval proc
      (closure (ids body env) (evaluate body (extend-env ids args env)))
      (primitive (procname argnum body)
                 (if (not (eq? (length args) argnum))
                     (eopl:error 'app-proc "Wrong number of arguments.")
                     (apply body args))))))

(define-datatype s-exp s-exp?
  (empty-list)
  (atom (a atom?))
  (cons-cell (ca s-exp?)
             (cd s-exp?)))


;                                                          
;                                                          
;                                                          
;                                                          
;   ####### ######   ### #  #######  ##### ###  ###   #### 
;   #  #  #  #   #  #   ##  #  #  #    #    ##   #   #   # 
;      #     # #    #          #       #    # #  #  #      
;      #     ###     ####      #       #    # #  #  #      
;      #     # #         #     #       #    #  # #  #   ###
;      #     #           #     #       #    #  # #  #    # 
;      #     #   #  ##   #     #       #    #   ##   #   # 
;     ###   ######  # ###     ###    ##### ###  ##    ###  
;                                                          
;                                                          
;                                                          
;                                                          

;;THERE ARE SOME INVALID TEST CASES HERE
(define archaic-test-list
  '("5" "a" "(if #t correct x)" "(if (lesser 4 5) correct x)" 
        "(cond ((equal 4 5) wrong) ((equal 5 5) correct) (else y))"
        "(let () x)" "(let ((x 5)) x)" "(let ((x 5) (y 10)) x)"
        "((lambda (x) ((lambda (y) (add y x)) 5)) 4)"))

;the output for evaluate should be a list of fives.
(define test-list
  '("(let () 5)" "(let ((x 5)) x)" "(let ((x 5) (y 10)) x)" "(let ((x 4)) (let ((y 1)) (add x y)))"
        "((lambda () 5) 4)" "((lambda (x y) (add y x)) 4 1)" "((lambda (x) ((lambda (y) (add y x)) 1)) 4)"
        "(letrec ((four (lambda (y) (add y 4)))) (four 1))"
        "(letrec ((useaddfour (lambda (z) (flyfour z)))(flyfour (lambda (y) (add y 4)))) (useaddfour 1))"))

(define test-unparse
  (lambda ()
    (map (lambda (x) (unparse (parse x))) test-list)))

(define test-evaluate
  (lambda ()
    (map (lambda (x) (run-eval (parse x))) test-list)))


(define letrec-test
  (lambda ()
    (run-eval (parse 
               "(letrec ((flyfour (lambda (y) (add y 4)))
                        (useaddfour (lambda (z) (flyfour z)))) (useaddfour 1))"))))

(define letrec-test2
  (lambda ()
    (run-eval (parse 
               "(letrec ((useaddfour (lambda (z) (flyfour z)))
                        (flyfour (lambda (y) (add y 4)))) (useaddfour 1))"))))